home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / program / swagd_f.zip / DRIVES.SWG / 0056_FORMAT FLOPPY.pas < prev    next >
Pascal/Delphi Source File  |  1993-11-21  |  32KB  |  1,049 lines
  1. {$R-,S-,I-,B-,F-,O+}
  2.  
  3. {---------------------------------------------------------
  4.  BIOS disk I/O routines for floppy drives. Supports DOS
  5.  real mode, DOS protected mode, and Windows. Requires
  6.  TP6, TPW, or BP7.
  7.  
  8.  All functions are for floppy disks only; no hard drives.
  9.  
  10.  See the individual types and functions in the interface of
  11.  this unit for more information. See the FMT.PAS sample
  12.  program for an example of formatting disks.
  13.  
  14.  For status code definitions, see the implementation of
  15.  function GetStatusStr.
  16.  
  17.  ---------------------------------------------------------
  18.  Based on a unit provided by Henning Jorgensen of Denmark.
  19.  Modified and cleaned up by TurboPower Software for pmode
  20.  and Windows operation.
  21.  
  22.  TurboPower Software
  23.  P.O. Box 49009
  24.  Colorado Springs, CO 80949-9009
  25.  
  26.  CompuServe: 76004,2611
  27.  
  28.  Version 1.0  10/25/93
  29.  Version 1.1  10/29/93
  30.    fix a dumb bug in the MediaArray check
  31.  ---------------------------------------------------------}
  32.  
  33. unit BDisk;
  34.   {-BIOS disk I/O routines for floppy drives}
  35.  
  36. interface
  37.  
  38. const
  39.   MaxRetries : Byte = 3;          {Number of automatic retries for
  40.                                    read, write, verify, format}
  41.  
  42. type
  43.   DriveNumber = 0..7;             {Acceptable floppy drive numbers}
  44.                                   {Generally, 0 = A, 1 = B}
  45.  
  46.   DriveType = 0..4;               {Floppy drive or disk types}
  47.                                   {0 = unknown or error
  48.                                    1 = 360K
  49.                                    2 = 1.2M
  50.                                    3 = 720K
  51.                                    4 = 1.44M}
  52.  
  53.   VolumeStr = String[11];         {String for volume labels}
  54.  
  55.   FormatAbortFunc =               {Prototype for format abort func}
  56.     function (Track : Byte;       {Track number being formatted, 0..MaxTrack}
  57.               MaxTrack : Byte;    {Maximum track number for this format}
  58.               Kind : Byte         {0 = format beginning}
  59.                                   {1 = formatting Track}
  60.                                   {2 = verifying Track}
  61.                                   {3 = writing boot and FAT}
  62.                                   {4 = format ending, Track = format status}
  63.               ) : Boolean;        {Return True to abort format}
  64.  
  65.  
  66. procedure ResetDrive(Drive : DriveNumber);
  67.   {-Reset drive system (function $00). Call after any other
  68.     disk function fails}
  69.  
  70.  
  71. function GetDiskStatus : Byte;
  72.   {-Get status of last int $13 operation (function $01)}
  73.  
  74.  
  75. function GetStatusStr(ErrNum : Byte) : String;
  76.   {-Return message string for any of the status codes used by
  77.     this unit.}
  78.  
  79.  
  80. function GetDriveType(Drive : DriveNumber) : DriveType;
  81.   {-Get drive type (function $08). Note that this returns the
  82.     type of the *drive*, not the type of the diskette in it.
  83.     GetDriveType returns 0 for an invalid drive.}
  84.  
  85.  
  86. function AllocBuffer(var P : Pointer; Size : Word) : Boolean;
  87.   {-Allocate a buffer useable in real and protected mode.
  88.     Buffers passed to ReadSectors and WriteSectors in pmode
  89.     *MUST* be allocated by using this function. AllocBuffer returns
  90.     False if sufficient memory is not available. P is also set to
  91.     nil in that case.}
  92.  
  93.  
  94. procedure FreeBuffer(P : Pointer; Size : Word);
  95.   {-Free buffer allocated by AllocBuffer. Size must match the
  96.     size originally passed to AllocBuffer. FreeBuffer does
  97.     nothing if P is nil.}
  98.  
  99.  
  100. function ReadSectors(Drive : DriveNumber;
  101.                      Track, Side, SSect, NSect : Byte;
  102.                      var Buffer) : Byte;
  103.   {-Read absolute disk sectors (function $02). Track, Side,
  104.     and SSect specify the location of the first sector to
  105.     read. NSect is the number of sectors to read. Buffer
  106.     must be large enough to hold these sectors. ReadSectors
  107.     returns a status code, 0 for success.}
  108.  
  109.  
  110. function WriteSectors(Drive : DriveNumber;
  111.                       Track, Side, SSect, NSect : Byte;
  112.                       var Buffer) : Byte;
  113.   {-Write absolute disk sectors (function $03). Track, Side,
  114.     and SSect specify the location of the first sector to
  115.     write. NSect is the number of sectors to write. Buffer
  116.     must contain all the data to write. WriteSectors
  117.     returns a status code, 0 for success.}
  118.  
  119.  
  120. function VerifySectors(Drive : DriveNumber;
  121.                        Track, Side, SSect, NSect : Byte) : Byte;
  122.   {-Verify absolute disk sectors (function $04). This
  123.     tests a computed CRC with the CRC stored along with the
  124.     sector. Track, Side, and SSect specify the location of
  125.     the first sector to verify. NSect is the number of
  126.     sectors to verify. VerifySectors returns a status code,
  127.     0 for success. Don't call VerifySectors on PC/XTs and
  128.     PC/ATs with a BIOS from 1985. It will overwrite the
  129.     stack.}
  130.  
  131.  
  132. function FormatDisk(Drive : DriveNumber; DType : DriveType;
  133.                     Verify : Boolean; MaxBadSects : Byte;
  134.                     VLabel : VolumeStr;
  135.                     FAF : FormatAbortFunc) : Byte;
  136.   {-Format drive that contains a disk of type DType. If Verify
  137.     is True, each track is verified after it is formatted.
  138.     MaxBadSects specifies the number of sectors that can be
  139.     bad before the format is halted. If VLabel is not an
  140.     empty string, FormatDisk puts the BIOS-level volume
  141.     label onto the diskette. It does *not* add a DOS-level
  142.     volume label. FAF is a user function hook that can be
  143.     used to display status during the format, and to abort
  144.     the format if the user so chooses. Parameters passed to
  145.     this function are described in FormatAbortFunc above.
  146.     FormatDisk also writes a boot sector and empty File
  147.     Allocation Tables for the disk. FormatDisk returns a
  148.     status code, 0 for success.}
  149.  
  150.  
  151. function EmptyAbortFunc(Track : Byte; MaxTrack : Byte; Kind : Byte) : Boolean;
  152.   {-Do-nothing abort function for FormatDisk}
  153.  
  154.   {========================================================================}
  155.  
  156. implementation
  157.  
  158. uses
  159. {$IFDEF DPMI}
  160.   WinApi,
  161.   Dos;
  162.   {$DEFINE pmode}
  163. {$ELSE}
  164. {$IFDEF Windows}
  165.   WinApi,
  166.   WinDos;
  167.   {$DEFINE pmode}
  168. {$ELSE}
  169.   Dos;
  170.   {$UNDEF pmode}
  171. {$ENDIF}
  172. {$ENDIF}
  173.  
  174. {$IFDEF Windows}
  175. type
  176.   Registers = TRegisters;
  177.   DateTime = TDateTime;
  178. {$ENDIF}
  179.  
  180. type
  181.   DiskRec =
  182.     record
  183.       SSZ : Byte;                 {Sector size}
  184.       SPT : Byte;                 {Sectors/track}
  185.       TPD : Byte;                 {Tracks/disk}
  186.       SPF : Byte;                 {Sectors/FAT}
  187.       DSC : Byte;                 {Directory sectors}
  188.       FID : Byte;                 {Format id for FAT}
  189.       BRD : array[0..13] of Byte; {Variable boot record data}
  190.     end;
  191.   DiskRecs = array[1..4] of DiskRec;
  192.   SectorArray = array[0..511] of Byte;
  193.  
  194. const
  195.   DData : DiskRecs =              {BRD starts at offset 13 of FAT}
  196.   ((SSZ : $02; SPT : $09; TPD : $27; SPF : $02; DSC : $07; FID : $FD; {5.25" - 360K}
  197.     BRD : ($02, $01, $00, $02, $70, $00, $D0, $02, $FD, $02, $00, $09, $00, $02)),
  198.    (SSZ : $02; SPT : $0F; TPD : $4F; SPF : $07; DSC : $0E; FID : $F9; {5.25" - 1.2M}
  199.     BRD : ($01, $01, $00, $02, $E0, $00, $60, $09, $F9, $07, $00, $0F, $00, $02)),
  200.    (SSZ : $02; SPT : $09; TPD : $4F; SPF : $03; DSC : $07; FID : $F9; {3.50" - 720K}
  201.     BRD : ($02, $01, $00, $02, $70, $00, $A0, $05, $F9, $03, $00, $09, $00, $02)),
  202.    (SSZ : $02; SPT : $12; TPD : $4F; SPF : $09; DSC : $0E; FID : $F0; {3.50" - 1.44M}
  203.     BRD : ($01, $01, $00, $02, $E0, $00, $40, $0B, $F0, $09, $00, $12, $00, $02)));
  204.  
  205.   BootRecord : SectorArray = {Standard boot program}
  206.   ($EB, $34, $90, $41, $4D, $53, $54, $20, $33, $2E, $30, $00, $02, $01, $01, $00, $02, $E0, $00, $40, $0B, $F0, $09, $00,
  207.    $12, $00, $02, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $12,
  208.    $00, $00, $00, $00, $01, $00, $FA, $33, $C0, $8E, $D0, $BC, $00, $7C, $16, $07, $BB, $78, $00, $36, $C5, $37, $1E, $56,
  209.    $16, $53, $BF, $2B, $7C, $B9, $0B, $00, $FC, $AC, $26, $80, $3D, $00, $74, $03, $26, $8A, $05, $AA, $8A, $C4, $E2, $F1,
  210.    $06, $1F, $89, $47, $02, $C7, $07, $2B, $7C, $FB, $CD, $13, $72, $67, $A0, $10, $7C, $98, $F7, $26, $16, $7C, $03, $06,
  211.    $1C, $7C, $03, $06, $0E, $7C, $A3, $3F, $7C, $A3, $37, $7C, $B8, $20, $00, $F7, $26, $11, $7C, $8B, $1E, $0B, $7C, $03,
  212.    $C3, $48, $F7, $F3, $01, $06, $37, $7C, $BB, $00, $05, $A1, $3F, $7C, $E8, $9F, $00, $B8, $01, $02, $E8, $B3, $00, $72,
  213.    $19, $8B, $FB, $B9, $0B, $00, $BE, $D6, $7D, $F3, $A6, $75, $0D, $8D, $7F, $20, $BE, $E1, $7D, $B9, $0B, $00, $F3, $A6,
  214.    $74, $18, $BE, $77, $7D, $E8, $6A, $00, $32, $E4, $CD, $16, $5E, $1F, $8F, $04, $8F, $44, $02, $CD, $19, $BE, $C0, $7D,
  215.    $EB, $EB, $A1, $1C, $05, $33, $D2, $F7, $36, $0B, $7C, $FE, $C0, $A2, $3C, $7C, $A1, $37, $7C, $A3, $3D, $7C, $BB, $00,
  216.    $07, $A1, $37, $7C, $E8, $49, $00, $A1, $18, $7C, $2A, $06, $3B, $7C, $40, $38, $06, $3C, $7C, $73, $03, $A0, $3C, $7C,
  217.    $50, $E8, $4E, $00, $58, $72, $C6, $28, $06, $3C, $7C, $74, $0C, $01, $06, $37, $7C, $F7, $26, $0B, $7C, $03, $D8, $EB,
  218.    $D0, $8A, $2E, $15, $7C, $8A, $16, $FD, $7D, $8B, $1E, $3D, $7C, $EA, $00, $00, $70, $00, $AC, $0A, $C0, $74, $22, $B4,
  219.    $0E, $BB, $07, $00, $CD, $10, $EB, $F2, $33, $D2, $F7, $36, $18, $7C, $FE, $C2, $88, $16, $3B, $7C, $33, $D2, $F7, $36,
  220.    $1A, $7C, $88, $16, $2A, $7C, $A3, $39, $7C, $C3, $B4, $02, $8B, $16, $39, $7C, $B1, $06, $D2, $E6, $0A, $36, $3B, $7C,
  221.    $8B, $CA, $86, $E9, $8A, $16, $FD, $7D, $8A, $36, $2A, $7C, $CD, $13, $C3, $0D, $0A, $4E, $6F, $6E, $2D, $53, $79, $73,
  222.    $74, $65, $6D, $20, $64, $69, $73, $6B, $20, $6F, $72, $20, $64, $69, $73, $6B, $20, $65, $72, $72, $6F, $72, $0D, $0A,
  223.    $52, $65, $70, $6C, $61, $63, $65, $20, $61, $6E, $64, $20, $73, $74, $72, $69, $6B, $65, $20, $61, $6E, $79, $20, $6B,
  224.    $65, $79, $20, $77, $68, $65, $6E, $20, $72, $65, $61, $64, $79, $0D, $0A, $00, $0D, $0A, $44, $69, $73, $6B, $20, $42,
  225.    $6F, $6F, $74, $20, $66, $61, $69, $6C, $75, $72, $65, $0D, $0A, $00, $49, $4F, $20, $20, $20, $20, $20, $20, $53, $59,
  226.    $53, $4D, $53, $44, $4F, $53, $20, $20, $20, $53, $59, $53, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00,
  227.    $00, $00, $00, $00, $00, $00, $55, $AA);
  228.  
  229.   MediaArray : array[DriveType, 1..2] of Byte =
  230.     (($00, $00),     {Unknown disk}
  231.      ($01, $02),     {360K disk}
  232.      ($00, $03),     {1.2M disk}
  233.      ($00, $04),     {720K disk}
  234.      ($00, $04));    {1.44M disk}
  235.  
  236. {$IFDEF pmode}
  237. type
  238.   DPMIRegisters =
  239.     record
  240.       DI : LongInt;
  241.       SI : LongInt;
  242.       BP : LongInt;
  243.       Reserved : LongInt;
  244.       BX : LongInt;
  245.       DX : LongInt;
  246.       CX : LongInt;
  247.       AX : LongInt;
  248.       Flags : Word;
  249.       ES : Word;
  250.       DS : Word;
  251.       FS : Word;
  252.       GS : Word;
  253.       IP : Word;
  254.       CS : Word;
  255.       SP : Word;
  256.       SS : Word;
  257.     end;
  258.  
  259.   function GetRealSelector(RealPtr : Pointer; Limit : Word) : Word;
  260.     {-Set up a selector to point to RealPtr memory}
  261.   type
  262.     OS =
  263.       record
  264.         O, S : Word;
  265.       end;
  266.   var
  267.     Status : Word;
  268.     Selector : Word;
  269.     Base : LongInt;
  270.   begin
  271.     GetRealSelector := 0;
  272.     Selector := AllocSelector(0);
  273.     if Selector = 0 then
  274.       Exit;
  275.     {Assure a read/write selector}
  276.     Status := ChangeSelector(CSeg, Selector);
  277.     Base := (LongInt(OS(RealPtr).S) shl 4)+LongInt(OS(RealPtr).O);
  278.     if SetSelectorBase(Selector, Base) = 0 then begin
  279.       Selector := FreeSelector(Selector);
  280.       Exit;
  281.     end;
  282.     Status := SetSelectorLimit(Selector, Limit);
  283.     GetRealSelector := Selector;
  284.   end;
  285.  
  286.   procedure GetRealIntVec(IntNo : Byte; var Vector : Pointer); Assembler;
  287.   asm
  288.     mov     ax,0200h
  289.     mov     bl,IntNo
  290.     int     31h
  291.     les     di,Vector
  292.     mov     word ptr es:[di],dx
  293.     mov     word ptr es:[di+2],cx
  294.   end;
  295.  
  296.   function RealIntr(IntNo : Byte; var Regs : DPMIRegisters) : Word; Assembler;
  297.   asm
  298.     xor     bx,bx
  299.     mov     bl,IntNo
  300.     xor     cx,cx        {StackWords = 0}
  301.     les     di,Regs
  302.     mov     ax,0300h
  303.     int     31h
  304.     jc      @@ExitPoint
  305.     xor     ax,ax
  306.   @@ExitPoint:
  307.   end;
  308. {$ENDIF}
  309.  
  310.   procedure Int13Call(var Regs : Registers);
  311.     {-Call int $13 for real or protected mode}
  312. {$IFDEF pmode}
  313.   var
  314.     Base : LongInt;
  315.     DRegs : DPMIRegisters;
  316. {$ENDIF}
  317.   begin
  318. {$IFDEF pmode}
  319.     {This pmode code is valid only for the AH values used in this unit}
  320.     FillChar(DRegs, SizeOf(DPMIRegisters), 0);
  321.     DRegs.AX := Regs.AX;
  322.     DRegs.BX := Regs.BX;
  323.     DRegs.CX := Regs.CX;
  324.     DRegs.DX := Regs.DX;
  325.     case Regs.AH of
  326.       2, 3, 5 :
  327.         {Calls that use ES as a buffer segment}
  328.         begin
  329.           Base := GetSelectorBase(Regs.ES);
  330.           if (Base <= 0) or (Base > $FFFF0) then begin
  331.             Regs.Flags := 1;
  332.             Regs.AX := 1;
  333.             Exit;
  334.           end;
  335.           DRegs.ES := Base shr 4;
  336.         end;
  337.     end;
  338.     if RealIntr($13, DRegs) <> 0 then begin
  339.       Regs.Flags := 1;
  340.       Regs.AX := 1;
  341.     end else begin
  342.       Regs.Flags := DRegs.Flags;
  343.       Regs.AX := DRegs.AX;
  344.       Regs.BX := DRegs.BX; {BX is returned by GetDriveType function only}
  345.     end;
  346.  
  347. {$ELSE}
  348.     Intr($13, Regs);
  349. {$ENDIF}
  350.   end;
  351.  
  352.   function GetDriveType(Drive : DriveNumber) : DriveType;
  353.   var
  354.     Regs : Registers;
  355.   begin
  356.     Regs.AH := $08;
  357.     Regs.DL := Drive;
  358.     Int13Call(Regs);
  359.     if Regs.AH = 0 then
  360.       GetDriveType := Regs.BL
  361.     else
  362.       GetDriveType := 0;
  363.   end;
  364.  
  365.   function GetDiskStatus : Byte;
  366.   var
  367.     Regs : Registers;
  368.   begin
  369.     Regs.AH := $01;
  370.     Int13Call(Regs);
  371.     GetDiskStatus := Regs.AL;
  372.   end;
  373.  
  374.   function GetStatusStr(ErrNum : Byte) : String;
  375.   var
  376.     NumStr : string[3];
  377.   begin
  378.     case ErrNum of
  379.       {Following codes are defined by the floppy BIOS}
  380.       $00 : GetStatusStr := '';
  381.       $01 : GetStatusStr := 'Invalid command';
  382.       $02 : GetStatusStr := 'Address mark not found';
  383.       $03 : GetStatusStr := 'Disk write protected';
  384.       $04 : GetStatusStr := 'Sector not found';
  385.       $06 : GetStatusStr := 'Floppy disk removed';
  386.       $08 : GetStatusStr := 'DMA overrun';
  387.       $09 : GetStatusStr := 'DMA crossed 64KB boundary';
  388.       $0C : GetStatusStr := 'Media type not found';
  389.       $10 : GetStatusStr := 'Uncorrectable CRC error';
  390.       $20 : GetStatusStr := 'Controller failed';
  391.       $40 : GetStatusStr := 'Seek failed';
  392.       $80 : GetStatusStr := 'Disk timed out';
  393.  
  394.       {Following codes are added by this unit}
  395.       $FA : GetStatusStr := 'Format aborted';
  396.       $FB : GetStatusStr := 'Invalid media type';
  397.       $FC : GetStatusStr := 'Too many bad sectors';
  398.       $FD : GetStatusStr := 'Disk bad';
  399.       $FE : GetStatusStr := 'Invalid drive or type';
  400.       $FF : GetStatusStr := 'Insufficient memory';
  401.     else
  402.       Str(ErrNum, NumStr);
  403.       GetStatusStr := 'Unknown error '+NumStr;
  404.     end;
  405.   end;
  406.  
  407.   procedure ResetDrive(Drive : DriveNumber);
  408.   var
  409.     Regs : Registers;
  410.   begin
  411.     Regs.AH := $00;
  412.     Regs.DL := Drive;
  413.     Int13Call(Regs);
  414.   end;
  415.  
  416.   function AllocBuffer(var P : Pointer; Size : Word) : Boolean;
  417.   var
  418.     L : LongInt;
  419.   begin
  420. {$IFDEF pmode}
  421.     L := GlobalDosAlloc(Size);
  422.     if L <> 0 then begin
  423.       P := Ptr(Word(L and $FFFF), 0);
  424.       AllocBuffer := True;
  425.     end else begin
  426.       P := nil;
  427.       AllocBuffer := False
  428.     end;
  429. {$ELSE}
  430.     if MaxAvail >= Size then begin
  431.       GetMem(P, Size);
  432.       AllocBuffer := True;
  433.     end else begin
  434.       P := nil;
  435.       AllocBuffer := False;
  436.     end;
  437. {$ENDIF}
  438.   end;
  439.  
  440.   procedure FreeBuffer(P : Pointer; Size : Word);
  441.   begin
  442.     if P = nil then
  443.       Exit;
  444. {$IFDEF pmode}
  445.     Size := GlobalDosFree(LongInt(P) shr 16);
  446. {$ELSE}
  447.     FreeMem(P, Size);
  448. {$ENDIF}
  449.   end;
  450.  
  451.   function CheckParms(DType : DriveType; Drive : DriveNumber) : Boolean;
  452.     {-Make sure drive and type are within range}
  453.   begin
  454.     CheckParms := False;
  455.     if (DType < 1) or (DType > 4) then
  456.       Exit;
  457.     if (Drive > 7) then
  458.       Exit;
  459.     CheckParms := True;
  460.   end;
  461.  
  462.   function SubfSectors(SubFunc : Byte;
  463.                        Drive : DriveNumber;
  464.                        Track, Side, SSect, NSect : Byte;
  465.                        var Buffer) : Byte;
  466.     {-Code shared by ReadSectors, WriteSectors, VerifySectors, FormatTrack}
  467.   var
  468.     Tries : Byte;
  469.     Done : Boolean;
  470.     Regs : Registers;
  471.   begin
  472.     Tries := 1;
  473.     Done := False;
  474.     repeat
  475.       Regs.AH := SubFunc;
  476.       Regs.AL := NSect;
  477.       Regs.CH := Track;
  478.       Regs.CL := SSect;
  479.       Regs.DH := Side;
  480.       Regs.DL := Drive;
  481.       Regs.ES := Seg(Buffer);
  482.       Regs.BX := Ofs(Buffer);
  483.       Int13Call(Regs);
  484.  
  485.       if Regs.AH <> 0 then begin
  486.         ResetDrive(Drive);
  487.         Inc(Tries);
  488.         if Tries > MaxRetries then
  489.           Done := True;
  490.       end else
  491.         Done := True;
  492.     until Done;
  493.  
  494.     SubfSectors := Regs.AH;
  495.   end;
  496.  
  497.   function ReadSectors(Drive : DriveNumber;
  498.                        Track, Side, SSect, NSect : Byte;
  499.                        var Buffer) : Byte;
  500.   begin
  501.     ReadSectors := SubfSectors($02, Drive, Track, Side, SSect, NSect, Buffer);
  502.   end;
  503.  
  504.   function WriteSectors(Drive : DriveNumber;
  505.                         Track, Side, SSect, NSect : Byte;
  506.                         var Buffer) : Byte;
  507.   begin
  508.     WriteSectors := SubfSectors($03, Drive, Track, Side, SSect, NSect, Buffer);
  509.   end;
  510.  
  511.   function VerifySectors(Drive : DriveNumber;
  512.                          Track, Side, SSect, NSect : Byte) : Byte;
  513.   var
  514.     Dummy : Byte;
  515.   begin
  516.     VerifySectors := SubfSectors($04, Drive, Track, Side, SSect, NSect, Dummy);
  517.   end;
  518.  
  519.   function SetDriveTable(DType : DriveType) : Boolean;
  520.     {-Set drive table parameters for formatting}
  521.   var
  522.     P : Pointer;
  523.     DBSeg : Word;
  524.     DBOfs : Word;
  525.   begin
  526.     SetDriveTable := False;
  527.  
  528. {$IFDEF pmode}
  529.     GetRealIntVec($1E, P);
  530.     DBSeg := GetRealSelector(P, $FFFF);
  531.     if DBSeg = 0 then
  532.       Exit;
  533.     DBOfs := 0;
  534. {$ELSE}
  535.     GetIntVec($1E, P);
  536.     DBSeg := LongInt(P) shr 16;
  537.     DBOfs := LongInt(P) and $FFFF;
  538. {$ENDIF}
  539.  
  540.     {Set gap length for formatting}
  541.     case DType of
  542.       1 : Mem[DBSeg:DBOfs+7] := $50; {360K}
  543.       2 : Mem[DBSeg:DBOfs+7] := $54; {1.2M}
  544.       3,
  545.       4 : Mem[DBSeg:DBOfs+7] := $6C; {720K or 1.44M}
  546.     end;
  547.  
  548.     {Set max sectors/track}
  549.     Mem[DBSeg:DBOfs+4] := DData[DType].SPT;
  550.  
  551. {$IFDEF pmode}
  552.     DBSeg := FreeSelector(DBSeg);
  553. {$ENDIF}
  554.  
  555.     SetDriveTable := True;
  556.   end;
  557.  
  558.   function GetMachineID : Byte;
  559.     {-Return machine ID code}
  560. {$IFDEF pmode}
  561.   var
  562.     SegFFFF : Word;
  563. {$ENDIF}
  564.   begin
  565. {$IFDEF pmode}
  566.     SegFFFF := GetRealSelector(Ptr($FFFF, $0000), $FFFF);
  567.     if SegFFFF = 0 then
  568.       GetMachineID := 0
  569.     else begin
  570.       GetMachineID := Mem[SegFFFF:$000E];
  571.       SegFFFF := FreeSelector(SegFFFF);
  572.     end;
  573. {$ELSE}
  574.     GetMachineID := Mem[$FFFF:$000E];
  575. {$ENDIF}
  576.   end;
  577.  
  578.   function IsATMachine : Boolean;
  579.     {-Return True if AT or better machine}
  580.   begin
  581.     IsATMachine := False;
  582.     if Lo(DosVersion) >= 3 then
  583.       case GetMachineId of
  584.         $FC, $F8 :  {AT or PS/2}
  585.           IsATMachine := True;
  586.       end;
  587.   end;
  588.  
  589.   function GetChangeLineType(Drive : DriveNumber; var CLT : Byte) : Byte;
  590.     {-Return change line type of drive}
  591.   var
  592.     Regs : Registers;
  593.   begin
  594.     Regs.AH := $15;
  595.     Regs.DL := Drive;
  596.     Int13Call(Regs);
  597.     if (Regs.Flags and FCarry) <> 0 then begin
  598.       GetChangeLineType := Regs.AH;
  599.       CLT := 0;
  600.     end else begin
  601.       GetChangeLineType := 0;
  602.       CLT := Regs.AH;
  603.     end;
  604.   end;
  605.  
  606.   function SetFloppyType(Drive : DriveNumber; FType : Byte) : Byte;
  607.     {-Set floppy type for formatting}
  608.   var
  609.     Tries : Byte;
  610.     Done : Boolean;
  611.     Regs : Registers;
  612.   begin
  613.     Tries := 1;
  614.     Done := False;
  615.     repeat
  616.       Regs.AH := $17;
  617.       Regs.AL := FType;
  618.       Regs.DL := Drive;
  619.       Int13Call(Regs);
  620.       if Regs.AH <> 0 then begin
  621.         ResetDrive(Drive);
  622.         Inc(Tries);
  623.         if Tries > MaxRetries then
  624.           Done := True;
  625.       end else
  626.         Done := True;
  627.     until Done;
  628.  
  629.     SetFloppyType := Regs.AH;
  630.   end;
  631.  
  632.   function SetMediaType(Drive : DriveType; TPD : Byte; SPT : Byte) : Byte;
  633.     {-Set media type for formatting}
  634.   var
  635.     Regs : Registers;
  636.   begin
  637.     Regs.AH := $18;
  638.     Regs.DL := Drive;
  639.     Regs.CH := TPD;
  640.     Regs.CL := SPT;
  641.     Int13Call(Regs);
  642.     SetMediaType := Regs.AH;
  643.   end;
  644.  
  645.   function FormatDisk(Drive : DriveNumber; DType : DriveType;
  646.                       Verify : Boolean; MaxBadSects : Byte;
  647.                       VLabel : VolumeStr;
  648.                       FAF : FormatAbortFunc) : Byte;
  649.   label
  650.     ExitPoint;
  651.   type
  652.     CHRNRec =
  653.       record
  654.         CTrack : Byte;            {Track  0..?}
  655.         CSide : Byte;             {Side   0..1}
  656.         CSect : Byte;             {Sector 1..?}
  657.         CSize : Byte;             {Size   0..?}
  658.       end;
  659.     CHRNArray = array[1..18] of CHRNRec;
  660.     FATArray = array[0..4607] of Byte;
  661.   var
  662.     Tries : Byte;
  663.     Track : Byte;
  664.     Side : Byte;
  665.     Sector : Byte;
  666.     RWritten : Byte;
  667.     RTotal : Byte;
  668.     FatNum : Byte;
  669.     BadSects : Byte;
  670.     ChangeLine : Byte;
  671.     DiskType : Byte;
  672.     Status : Byte;
  673.     Done : Boolean;
  674.     Trash : Word;
  675.     DT : DateTime;
  676.     VDate : LongInt;
  677.     Regs : Registers;
  678.     BootPtr : ^SectorArray;
  679.     CHRN : ^CHRNArray;
  680.     FATs : ^FATArray;
  681.  
  682.     procedure MarkBadSector(Track, Side, Sector : Byte);
  683.     const
  684.       BadMark = $FF7;             {Bad cluster mark}
  685.     var
  686.       CNum : Integer;             {Cluster number}
  687.       FOfs : Word;                {Offset into fat for this cluster}
  688.       FVal : Word;                {FAT value for this cluster}
  689.       OFVal : Word;               {Old FAT value for this cluster}
  690.     begin
  691.       CNum := (((((Track*2)+Side)*DData[DType].SPT)+Sector-RTotal-2) div
  692.               DData[DType].BRD[0])+2;
  693.       if CNum > 1 then begin
  694.         {Sector is in data space}
  695.         FOfs := (CNum*3) div 2;
  696.         Move(FATs^[FOfs], FVal, 2);
  697.         if Odd(CNum) then
  698.           OFVal := (FVal and (BadMark shl 4))
  699.         else
  700.           OFVal := (FVal and BadMark);
  701.         if OFVal = 0 then begin
  702.           {Not already marked bad, mark it}
  703.           if Odd(CNum) then
  704.             FVal := (FVal or (BadMark shl 4))
  705.           else
  706.             FVal := (FVal or BadMark);
  707.           Move(FVal, FATs^[FOfs], 2);
  708.           {Add to bad sector count}
  709.           Inc(BadSects, DData[DType].BRD[0]);
  710.         end;
  711.       end;
  712.     end;
  713.  
  714.   begin
  715.     {Validate parameters. Can't do anything unless these are reasonable}
  716.     if not CheckParms(DType, Drive) then
  717.       Exit;
  718.  
  719.     {Initialize buffer pointers in case of failure}
  720.     FATs := nil;
  721.     CHRN := nil;
  722.     BootPtr := nil;
  723.  
  724.     {Status proc: starting format}
  725.     if FAF(0, DData[DType].TPD, 0) then begin
  726.       Status := $FA;
  727.       goto ExitPoint;
  728.     end;
  729.  
  730.     {Error code for invalid drive or media type}
  731.     Status := $FE;
  732.  
  733.     case GetDriveType(Drive) of
  734.       1 : {360K drive formats only 360K disks}
  735.         if DType <> 1 then
  736.           goto ExitPoint;
  737.       2 : {1.2M drive formats 360K or 1.2M disk}
  738.         if DType > 2 then
  739.           goto ExitPoint;
  740.       3 : {720K drive formats only 720K disks}
  741.         if DType <> 3 then
  742.           goto ExitPoint;
  743.       4 : {1.44M drive formats 720K or 1.44M disks}
  744.         if Dtype < 3 then
  745.           goto ExitPoint;
  746.     else
  747.       goto ExitPoint;
  748.     end;
  749.  
  750.     {Error code for out-of-memory or DPMI error}
  751.     Status := $FF;
  752.  
  753.     {Allocate buffers}
  754.     if not AllocBuffer(Pointer(FATs), SizeOf(FATArray)) then
  755.       goto ExitPoint;
  756.     if not AllocBuffer(Pointer(CHRN), SizeOf(CHRNArray)) then
  757.       goto ExitPoint;
  758.     if not AllocBuffer(Pointer(BootPtr), SizeOf(BootRecord)) then
  759.       goto ExitPoint;
  760.  
  761.     {Initialize boot record}
  762.     Move(BootRecord, BootPtr^, SizeOf(BootRecord));
  763.     Move(DData[DType].BRD, BootPtr^[13], 14);
  764.  
  765.     {Initialize the FAT table}
  766.     FillChar(FATs^, SizeOf(FATArray), 0);
  767.     FATs^[0] := DData[DType].FID;
  768.     FATs^[1] := $FF;
  769.     FATs^[2] := $FF;
  770.  
  771.     {Set drive table parameters by patching drive table in memory}
  772.     if not SetDriveTable(DType) then
  773.       goto ExitPoint;
  774.  
  775.     {On AT class machines, set format parameters via BIOS}
  776.     if IsATMachine then begin
  777.       {Get change line type: 1 -> 360K drive, 2 -> 1.2M or 3.5" drive}
  778.       Status := GetChangeLineType(Drive, ChangeLine);
  779.       if Status <> 0 then
  780.         goto ExitPoint;
  781.       if (ChangeLine < 1) or (ChangeLine > 2) then begin
  782.         Status := 1;
  783.         goto ExitPoint;
  784.       end;
  785.  
  786.       {Determine floppy type for SetFloppyType call}
  787.       DiskType := MediaArray[DType, ChangeLine];
  788.       if DiskType = 0 then begin
  789.         Status := $FB;
  790.         goto ExitPoint;
  791.       end;
  792.  
  793.       {Set floppy type for drive}
  794.       Status := SetFloppyType(Drive, DiskType);
  795.       if Status <> 0 then
  796.         goto ExitPoint;
  797.  
  798.       {Set media type for format}
  799.       Status := SetMediaType(Drive, DData[DType].TPD, DData[DType].SPT);
  800.       if Status <> 0 then
  801.         goto ExitPoint;
  802.     end;
  803.  
  804.     {Format each sector}
  805.     ResetDrive(Drive);
  806.     BadSects := 0;
  807.  
  808.     for Track := 0 to DData[DType].TPD do begin
  809.       {Status proc: formatting track}
  810.       if FAF(Track, DData[DType].TPD, 1) then begin
  811.         Status := $FA;
  812.         goto ExitPoint;
  813.       end;
  814.  
  815.       for Side := 0 to 1 do begin
  816.         {Initialize CHRN for this sector}
  817.         for Sector := 1 to DData[DType].SPT do
  818.           with CHRN^[Sector] do begin
  819.             CTrack := Track;
  820.             CSide := Side;
  821.             CSect := Sector;
  822.             CSize := DData[DType].SSZ;
  823.           end;
  824.  
  825.         {Format this sector, with retries}
  826.         Status := SubfSectors($05, Drive, Track, Side,
  827.                               1, DData[DType].SPT, CHRN^);
  828.         if Status <> 0 then
  829.           goto ExitPoint;
  830.       end;
  831.  
  832.       if Verify then begin
  833.         {Status proc: verifying track}
  834.         if FAF(Track, DData[DType].TPD, 2) then begin
  835.           Status := $FA;
  836.           goto ExitPoint;
  837.         end;
  838.  
  839.         for Side := 0 to 1 do
  840.           {Verify the entire track}
  841.           if VerifySectors(Drive, Track, Side,
  842.                            1, DData[DType].SPT) <> 0 then begin
  843.             if Track = 0 then begin
  844.               {Disk bad}
  845.               Status := $FD;
  846.               goto ExitPoint;
  847.             end;
  848.  
  849.             for Sector := 1 to DData[DType].SPT do
  850.               if VerifySectors(Drive, Track, Side,
  851.                                Sector, 1) <> 0 then begin
  852.                 MarkBadSector(Track, Side, Sector);
  853.                 if BadSects > MaxBadSects then begin
  854.                   Status := $FC;
  855.                   goto ExitPoint;
  856.                 end;
  857.               end;
  858.           end;
  859.       end;
  860.     end;
  861.  
  862.     {Status proc: writing boot and FAT}
  863.     if FAF(0, DData[DType].TPD, 3) then begin
  864.       Status := $FA;
  865.       goto ExitPoint;
  866.     end;
  867.  
  868.     {Write boot record}
  869.     Status := WriteSectors(Drive, 0, 0, 1, 1, BootPtr^);
  870.     if Status <> 0 then begin
  871.       Status := $FD;
  872.       goto ExitPoint;
  873.     end;
  874.  
  875.     {Write FATs and volume label}
  876.     Track := 0;
  877.     Side := 0;
  878.     Sector := 2;
  879.     FatNum := 0;
  880.     RTotal := (2*DData[DType].SPF)+DData[DType].DSC;
  881.     for RWritten := 0 to RTotal-1 do begin
  882.       if Sector > DData[DType].SPT then begin
  883.         Sector := 1;
  884.         Inc(Side);
  885.       end;
  886.  
  887.       if RWritten < (2*DData[DType].SPF) then begin
  888.         if FatNum > DData[DType].SPF-1 then
  889.           FatNum := 0;
  890.       end else begin
  891.         FillChar(FATs^, 512, 0);
  892.         if ((VLabel <> '') and (RWritten = 2*DData[DType].SPF)) then begin
  893.           {Put in volume label}
  894.           for Trash := 1 to Length(VLabel) do
  895.             VLabel[Trash] := Upcase(VLabel[Trash]);
  896.           while Length(VLabel) < 11 do
  897.             VLabel := VLabel+' ';
  898.           Move(VLabel[1], FATs^, 11);
  899.           FATs^[11] := 8;
  900.           GetDate(DT.Year, DT.Month, DT.Day, Trash);
  901.           GetTime(DT.Hour, DT.Min, DT.Sec, Trash);
  902.           PackTime(DT, VDate);
  903.           Move(VDate, FATs^[22], 4);
  904.         end;
  905.         FatNum := 0;
  906.       end;
  907.  
  908.       if WriteSectors(Drive, Track, Side,
  909.                       Sector, 1, FATs^[FatNum*512]) <> 0 then begin
  910.         Status := $FD;
  911.         goto ExitPoint;
  912.       end;
  913.  
  914.       Inc(Sector);
  915.       Inc(FatNum);
  916.     end;
  917.  
  918.     {Success}
  919.     Status := 0;
  920.  
  921. ExitPoint:
  922.     FreeBuffer(BootPtr, SizeOf(BootRecord));
  923.     FreeBuffer(CHRN, SizeOf(CHRNArray));
  924.     FreeBuffer(FATs, SizeOf(FATArray));
  925.  
  926.     {Status proc: ending format}
  927.     Done := FAF(Status, DData[DType].TPD, 4);
  928.     FormatDisk := Status;
  929.   end;
  930.  
  931.   function EmptyAbortFunc(Track, MaxTrack : Byte; Kind : Byte) : Boolean;
  932.   begin
  933.     EmptyAbortFunc := False;
  934.   end;
  935.  
  936. end.
  937.  
  938. { -------------------------------    DEMO PROGRAM   -------------------- }
  939. { -------------------------------     CUT HERE      ---------------------}
  940.  
  941. {$R-,S-,I-}
  942.  
  943. program Fmt;
  944.   {-Simple formatting program to demonstate DISKB unit}
  945.  
  946. uses
  947. {$IFDEF Windows}
  948.   WinCrt,
  949. {$ENDIF}
  950.   BDisk;
  951.  
  952. const
  953.   ESC = #27;
  954.   CR = #13;
  955.  
  956. type
  957.   CharSet = set of Char;
  958.  
  959. var
  960.   DLet : Char;
  961.   DTyp : Char;
  962.   Verf : Char;
  963.   GLet : Char;
  964.   DNum : Byte;
  965.   Status : Byte;
  966.   VStr : VolumeStr;
  967.  
  968. const
  969.   DriveTypeName : array[DriveType] of string[5] =
  970.     ('other', '360K', '1.2M', '720K', '1.44M');
  971.  
  972. {$IFNDEF Windows}
  973.   function ReadKey : Char; assembler;
  974.     {-Low budget readkey routine}
  975.   asm
  976.     xor ah,ah
  977.     int 16h
  978.   end;
  979. {$ENDIF}
  980.  
  981.   function GetKey(Prompt : String; OKSet : CharSet) : Char;
  982.     {-Get and return a key in the OKSet}
  983.   var
  984.     Ch : Char;
  985.   begin
  986.     Write(Prompt);
  987.     repeat
  988.       Ch := Upcase(ReadKey);
  989.       if Ch = ESC then begin
  990.         WriteLn;
  991.         Halt;
  992.       end;
  993.     until (Ch in OKSet);
  994.     if Ch <> CR then
  995.       Write(Ch);
  996.     WriteLn;
  997.     GetKey := Ch;
  998.   end;
  999.  
  1000.   function AbortFunc(Track, MaxTrack : Byte; Kind : Byte) : Boolean; far;
  1001.     {-Display formatting status. Could check for abort here too}
  1002.   begin
  1003.     case Kind of
  1004.       0 : {Format beginning}
  1005.         Write('Formatting     ');
  1006.       1 : {Formatting track}
  1007.         Write(^H^H^H^H, ((Track*100) div MaxTrack):3, '%');
  1008.       2 : {Verifying track}
  1009.         Write(^H, 'V');
  1010.       3 : {Writing boot and FAT}
  1011.         Write(^H^H^H^H^H^H^H^H^H^H^H^H^H^H^H, 'Writing boot and FAT');
  1012.       4 : {Format ending}
  1013.         begin
  1014.           Write(^H^H^H^H^H^H^H^H^H^H^H^H^H^H^H^H^H^H^H^H);
  1015.           {Track returns final status code in this case}
  1016.           if Track = 0 then
  1017.             WriteLn('Formatted successfully')
  1018.           else
  1019.             WriteLn('Format failed: ', GetStatusStr(Track));
  1020.         end;
  1021.     end;
  1022.     AbortFunc := False;
  1023.   end;
  1024.  
  1025. begin
  1026.   WriteLn('Floppy Formatter: <Esc> to exit');
  1027.  
  1028.   {Get formatting parameters}
  1029.   DLet := GetKey('Drive to format? (A or B): ', ['A'..'B']);
  1030.   DTyp := GetKey('Disk type? (1=360K, 2=1.2M, 3=720K, 4=1.44M): ', ['1'..'4']);
  1031.   Verf := GetKey('Verify? (Y or N) ', ['N', 'Y']);
  1032.   Write('Volume label? ');
  1033.   ReadLn(VStr);
  1034.   GLet := GetKey('Insert disk and press <Enter> ', [#13]);
  1035.  
  1036.   {Compute drive number}
  1037.   DNum := Byte(DLet)-Byte('A');
  1038.  
  1039.   WriteLn('Drive type is ', DriveTypeName[GetDriveType(DNum)]);
  1040.  
  1041.   Status := FormatDisk(DNum,                    {drive number}
  1042.                        Byte(DTyp)-Byte('0'),    {format type}
  1043.                        (Verf = 'Y'),            {verify?}
  1044.                        10,                      {max bad sectors}
  1045.                        VStr,                    {volume label}
  1046.                        AbortFunc);              {abort function}
  1047.   {AbortFunc reports the status}
  1048. end.
  1049.